home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / doors_1 / fd200.zip / FD_DOS.PAS < prev    next >
Pascal/Delphi Source File  |  1988-02-27  |  11KB  |  452 lines
  1. procedure wait_for_key;
  2. var       anykey : char;
  3. begin
  4.   repeat until keypressed;
  5.   anykey := readkey;
  6.   if (anykey = #0) then anykey := readkey;
  7. end;
  8.  
  9. procedure press_key;
  10. begin
  11.   write('                      Press any key to continue');
  12.   wait_for_key;
  13.   writeln;
  14. end;
  15.  
  16. procedure nbr_input(var nbr : integer);
  17. var num : any_string;
  18.     n,e : integer;
  19. begin
  20.   num := '';
  21.   repeat
  22.     repeat
  23.       key := readkey;
  24.     until (key in [^H,^M,#27,'0'..'9']);
  25.     if (key = #0) then
  26.     begin
  27.       key := readkey;                 { destroy all function key input }
  28.       key := null;
  29.     end;
  30.     case key of
  31.       #27   : num := '';                   { cancel input }
  32.       ^H    : if length(num) > 0 then       { backspace    }
  33.               begin
  34.                 num[0] := chr(ord(num[0]) - 1);
  35.                 write(^H,' ',^H);
  36.               end;
  37.       ^M,
  38.       null  : ;                            { all values entered }
  39.       else
  40.         begin
  41.           write(key);
  42.           num := num + key;
  43.         end;
  44.     end;
  45.   until (key in [#27,^M]);
  46.   val(num,n,e);
  47.   if (length(num) > 0) then nbr := n;
  48. end;
  49.  
  50. function str_input(n : integer): any_string;
  51. var inp : any_string;
  52.     i   : integer;
  53. begin
  54.   inp := '';
  55.   repeat
  56.     repeat
  57.       key := readkey;
  58.     until (key in [^H,^M,#27,#32..#127]);
  59.     if (key = #27) AND keypressed then
  60.     begin
  61.       key := readkey;                   { destroy all function key input }
  62.       key := null;
  63.     end;
  64.     case key of
  65.       #27   : inp := '';                   { cancel input }
  66.       ^H    : if length(inp) > 0 then      { backspace    }
  67.               begin
  68.                 inp[0] := chr(ord(inp[0]) - 1);
  69.                 write(^H,' ',^H);
  70.               end;
  71.       ^M,
  72.       null  : ;                            { return       }
  73.       else
  74.         if length(inp) < n then
  75.         begin
  76.           write(key);
  77.           inp := inp + key;
  78.         end;
  79.     end;
  80.   until (key in [#27,^M]);
  81.   str_input := inp;
  82. end;
  83.  
  84. procedure Frame(UpperLeftX, UpperLeftY, LowerRightX, LowerRightY: Integer);
  85. var  I : Integer;
  86.  
  87. begin {Frame}
  88.   GotoXY(UpperLeftX, UpperLeftY);
  89.   Write(chr(218));
  90.   for I := (UpperLeftX + 1) to (LowerRightX - 1) do
  91.   begin
  92.     Write(chr(196));
  93.   end;
  94.   Write(chr(191));
  95.   for I := (UpperLeftY + 1) to (LowerRightY - 1) do
  96.   begin
  97.     GotoXY(UpperLeftX , I);  Write(chr(179));
  98.     GotoXY(LowerRightX, I);  Write(chr(179));
  99.   end;
  100.   GotoXY(UpperLeftX, LowerRightY);
  101.   Write(chr(192));
  102.   for I := (UpperLeftX + 1) to (LowerRightX - 1) do
  103.   begin
  104.     Write(chr(196));
  105.   end;
  106.   Write(chr(217));
  107. end; {Frame}
  108.  
  109. function Date: DateString;
  110. var
  111.   gy, gm, gd, gdw : word;
  112.   month,day:     string[2];
  113.   year:          string[2];
  114.   yr:            string[4];
  115. begin
  116.   GetDate(gy,gm,gd,gdw);
  117.   str(gy,yr);
  118.   str(gd,day);
  119.   str(gm,month);
  120.   year := '  ';
  121.   year[1] := yr[3];
  122.   year[2] := yr[4];
  123.   if (month[0] = ^A) then month := '0' + month;
  124.   if (day[0] = ^A) then day := '0' + day;
  125.   date := month+'/'+day+'/'+year;
  126. end;
  127.  
  128. function todays_log_name: File_Type;
  129. var  s : File_Type;
  130. begin
  131.   s := date;
  132.   s[3] := '_';
  133.   s[6] := '_';
  134.   s := s + '.LOG';
  135.   todays_log_name := s;
  136. end;
  137.  
  138. function time: TimeString;
  139. var
  140.   gh, gm, gs, gs100 : word;
  141.   hour,min:     string[2];
  142.  
  143. begin
  144.   GetTime(gh, gm, gs, gs100);
  145.   begin
  146.     str(gh, hour);                 {convert to string}
  147.     str(gm,min);                       { " }
  148.   end;
  149.   if (hour[0] = #1) then hour := '0' + hour;
  150.   if (min[0]  = #1) then min  := '0' + min;
  151.   time := hour + ':' + min;
  152. end;
  153.  
  154. procedure set_date_time;
  155. var sec100 : word;
  156. begin
  157.   if (time_zone <> 0) then
  158.   begin
  159.     GetDate(year,month,day,dow);
  160.     GetTime(hour,min,sec,sec100);
  161.     hour := hour + time_zone;
  162.     if (hour > 23) then
  163.     begin
  164.       hour := hour - 24;
  165.       day := day + 1;
  166.       if (day > nbr_days[month]) then
  167.       begin
  168.         day := 1;
  169.         month := month + 1;
  170.         if (month > 12) then
  171.         begin
  172.           month := 1;
  173.           year := year + 1;
  174.         end;
  175.       end;
  176.     end;
  177.   SetDate(year,month,day);
  178.   SetTime(hour,min,sec,sec100);;
  179.   end;
  180. end;
  181.  
  182. procedure reset_date_time;
  183. var sec100 : word;
  184. begin
  185.   if (time_zone <> 0) then
  186.   begin
  187.     GetDate(year,month,day,dow);
  188.     GetTime(hour,min,sec,sec100);
  189.     hour := hour - time_zone;
  190.     if (hour < 0) then
  191.     begin
  192.       hour := hour + 24;
  193.       day := day - 1;
  194.       if (day = 0) then
  195.       begin
  196.         month := month - 1;
  197.         if (month = 0) then
  198.         begin
  199.           month := 12;
  200.           year := year - 1;
  201.         end;
  202.         day := nbr_days[month];
  203.       end;
  204.     end;
  205.   SetDate(year,month,day);
  206.   SetTime(hour,min,sec,sec100);;
  207.   end;
  208. end;
  209.  
  210. procedure directory;
  211.  
  212. type
  213.   filename = string[13];
  214.   dtapointer = ^dtarecord;
  215.   dtarecord = record
  216.                 dosreserved : array[1..21] of byte;
  217.                 attribute   : byte;
  218.                 filetime,
  219.                 filedate,
  220.                 sizelow,
  221.                 sizehigh    : integer;
  222.                 foundname   : array[1..13] of char;
  223.               end;
  224.  
  225. const
  226.   seekattrib = $10;
  227.  
  228. var
  229.   transferrec : dtapointer;
  230.   matchptrn   : file_type;
  231.   retname     : filename;
  232.   filsize     : real;
  233.   count       : integer;
  234.   nofind, lastfile, subdirec  : boolean;
  235.   local_image : array[0..3999] of byte;
  236.  
  237.   procedure pointdta(var dtarec : dtapointer);
  238.   const  getdta = $2F00;
  239.   var    regs : registers;
  240.   begin
  241.     regs.ax := getdta;
  242.     MsDos(regs);
  243.     dtarec := ptr(regs.es,regs.bx);
  244.   end;
  245.  
  246.   function sizeoffile(hiword, loword : integer) : real;
  247.   var  bigno, size : real;
  248.   begin
  249.     bigno := (MaxInt *2.0) + 2;
  250.     if (hiword < 0) then size := (bigno + hiword) * bigno
  251.        else size := hiword * bigno;
  252.     if (loword >= 0) then size := size + loword
  253.        else size := size + (bigno + loword);
  254.     sizeoffile := size;
  255.   end;
  256.  
  257.   procedure findfirst(pattern : file_type;
  258.                       var found : filename;
  259.                       var size  : real;
  260.                       var nomatch : boolean;
  261.                       var lastone : boolean;
  262.                       var subdir : boolean);
  263.   const  findfirst = $4E00;
  264.   type   asciiz = array[1..64] of char;
  265.   var    filespec : asciiz;
  266.          regs     : registers;
  267.          posinstr,
  268.          count    : integer;
  269.          foundlen : byte absolute found;
  270.   begin
  271.     for posinstr := 1 to length(pattern) do
  272.       filespec[posinstr] := pattern[posinstr];
  273.     filespec[length(pattern)+1] := null;
  274.     with regs do
  275.     begin
  276.       ds := seg(filespec);
  277.       dx := ofs(filespec);
  278.       cx := seekattrib;
  279.       ax := findfirst;
  280.       MsDos(regs);
  281.       if (flags AND 1) > 0 then
  282.         begin
  283.           case ax of
  284.             2  :  begin
  285.                     nomatch := TRUE;
  286.                     lastone := TRUE;
  287.                   end;
  288.            18  :  begin
  289.                     nomatch := FALSE;
  290.                     lastone := TRUE;
  291.                   end;
  292.           end;
  293.         end
  294.       else
  295.         begin
  296.           nomatch := FALSE;
  297.           lastone := FALSE;
  298.         end;
  299.       end;
  300.     if (NOT nomatch) then
  301.   with transferrec^ do
  302.     begin
  303.       found := foundname;
  304.       count := 0;
  305.       while found[count] <> null do count := count + 1;
  306.       foundlen := count;
  307.       for count := length(found) + 1 to 15 { 13 } do
  308.         found := found + ' ';
  309.       if (attribute AND seekattrib) > 0
  310.         then subdir := TRUE
  311.         else subdir := FALSE;
  312.       if NOT subdir
  313.         then size := sizeoffile(sizehigh,sizelow)
  314.         else size := 0.0;
  315.     end;
  316.   end;
  317.  
  318.   procedure findnext(var found : filename;
  319.                      var size  : real;
  320.                      var lastone : boolean;
  321.                      var subdir : boolean);
  322.   const   findnext = $4F00;
  323.   var     regs : registers;
  324.           count : integer;
  325.           foundlen : byte absolute found;
  326.   begin
  327.     with regs do
  328.     begin
  329.       ax := findnext;
  330.       MsDos(regs);
  331.       if ((flags AND 1) > 0) AND (ax = 18)
  332.           then lastone := TRUE
  333.           else lastone := FALSE;
  334.     end;
  335.     with transferrec^ do
  336.     begin
  337.       found := foundname;
  338.       count := 0;
  339.       while found[count] <> null do count := count + 1;
  340.       foundlen := count;
  341.       for count := length(found) + 1 to 15 { 13 } do
  342.         found := found + ' ';
  343.       if (attribute AND seekattrib) > 0
  344.         then subdir := TRUE
  345.         else subdir := FALSE;
  346.       if NOT subdir
  347.         then size := sizeoffile(sizehigh,sizelow)
  348.         else size := 0.0;
  349.     end;
  350.   end;
  351.  
  352. begin
  353.   move(video,local_image,4000);
  354.   window(1,1,80,24);
  355.   textcolor(15); textbackground(0);
  356.   frame(4,3,77,15);
  357.   window(5,4,76,14);
  358.   clrscr;
  359.   write('File Name Pattern: ');
  360.   readln(matchptrn);
  361.   if matchptrn = '' then matchptrn := '*.*';
  362.   count := 0;
  363.   pointdta(transferrec);
  364.   findfirst(matchptrn,retname,filsize,nofind,lastfile,subdirec);
  365.   if nofind OR lastfile
  366.     then writeln('File not found.')
  367.     else
  368.       begin
  369.       clrscr;
  370.         while (NOT lastfile) do
  371.           begin
  372.             write(retname ,':',filsize:8:0,'  ')  ;
  373.             count := count + 1;
  374.             if count = 30 then
  375.             begin
  376.               press_key;
  377.               count := 0;
  378.             end;
  379.             findnext(retname,filsize,lastfile,subdirec);
  380.           end;
  381.         end;
  382.   if count < 30 then
  383.   begin
  384.     writeln;
  385.     press_key;
  386.   end;
  387.   move(local_image,video,4000);
  388. end;
  389.  
  390. procedure get_file_name(var name : file_type;
  391.                         xp,yp : integer;
  392.                         prompt : any_string;
  393.                         x1,y1,x2,y2 : integer);
  394. var i,x,y : integer;
  395.     key : char;
  396.     f,b : integer;
  397. begin
  398.   name := '';
  399.   gotoxy(xp,yp); ClrEol;
  400.   writeln('Enter filename <ctrl F> directory');
  401.   if prompt > ''
  402.     then write('...........[',prompt,'] ')
  403.     else write('...........');
  404.   repeat
  405.     repeat until keypressed;
  406.     key := readkey;
  407.     if (key = #0) then
  408.       begin
  409.         key := readkey;
  410.         key := null;
  411.       end;
  412.     if (key = ^F) then
  413.       begin
  414.         save_attr(f,b,x1,y1);
  415.         x := WhereX;  y := WhereY;
  416.         directory;
  417.         restore_attr(f,b);
  418.         window(x1,y1,x2,y2);
  419.         gotoxy(x,y);
  420.       end;
  421.   until (key in [^M,chr(32)..chr(127)]);
  422.   if (key <> ^M) then
  423.     begin
  424.       write(key);
  425.       name := key;
  426.       repeat
  427.         key := readkey;
  428.         if (key = ^H) and (ord(name[0]) > 0)
  429.         then
  430.           begin
  431.             name[0] := chr(ord(name[0]) - 1);
  432.             write(^H,' ',^H);
  433.           end
  434.         else
  435.           if (key > ' ') then
  436.             begin
  437.               write(key);
  438.               name := name + key;
  439.             end;
  440.         if (key = #0) then key := readkey;
  441.       until (key = #13);
  442.     end;
  443. end;
  444.  
  445. procedure UpperCase(VAR str : any_string);
  446. var i : integer;
  447. begin
  448.   if length(str) > 0 then
  449.     for i := 1 to length(str) do
  450.       if str[i] in ['a'..'z'] then str[i] := chr(ord(str[i]) AND $DF);
  451. end;
  452.